home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 2002 November / SGI Freeware 2002 November - Disc 2.iso / dist / fw_guile.idb / usr / freeware / share / guile / 1.4 / ice-9 / readline.scm.z / readline.scm
Text File  |  2002-07-08  |  6KB  |  188 lines
  1. ;;;; readline.scm --- support functions for command-line editing
  2. ;;;;
  3. ;;;;     Copyright (C) 1997, 1999, 2000 Free Software Foundation, Inc.
  4. ;;;; 
  5. ;;;; This program is free software; you can redistribute it and/or modify
  6. ;;;; it under the terms of the GNU General Public License as published by
  7. ;;;; the Free Software Foundation; either version 2, or (at your option)
  8. ;;;; any later version.
  9. ;;;; 
  10. ;;;; This program is distributed in the hope that it will be useful,
  11. ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12. ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13. ;;;; GNU General Public License for more details.
  14. ;;;; 
  15. ;;;; You should have received a copy of the GNU General Public License
  16. ;;;; along with this software; see the file COPYING.  If not, write to
  17. ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
  18. ;;;; Boston, MA 02111-1307 USA
  19. ;;;; 
  20. ;;;; Contributed by Daniel Risacher <risacher@worldnet.att.net>.
  21. ;;;; Extensions based upon code by
  22. ;;;; Andrew Archibald <aarchiba@undergrad.math.uwaterloo.ca>.
  23.  
  24. (define-module (ice-9 readline)
  25.   :use-module (ice-9 session)
  26.   :use-module (ice-9 regex)
  27.   :no-backtrace)
  28.  
  29. ;;; Dynamically link the glue code for accessing the readline library,
  30. ;;; but only when it isn't already present.
  31.  
  32. (if (not (feature? 'readline))
  33.     (dynamic-call "scm_init_readline" (dynamic-link "libguilereadline.so")))
  34.  
  35. (if (not (feature? 'readline))
  36.     (scm-error 'misc-error
  37.            #f
  38.            "readline is not provided in this Guile installation"
  39.            '()
  40.            '()))
  41.  
  42. ;;; MDJ 980513 <djurfeldt@nada.kth.se>:
  43. ;;; There should probably be low-level support instead of this code.
  44.  
  45. (define prompt "")
  46. (define prompt2 "")
  47. (define input-port (current-input-port))
  48. (define output-port (current-output-port))
  49. (define read-hook #f)
  50.  
  51. (define (make-readline-port)
  52.   (let ((read-string "")
  53.     (string-index -1))
  54.     (letrec ((get-character
  55.           (lambda ()
  56.         (cond 
  57.          ((eof-object? read-string)
  58.           read-string)
  59.          ((>= string-index (string-length read-string))
  60.           (begin
  61.             (set! string-index -1)
  62.             #\nl))
  63.          ((= string-index -1)
  64.           (begin
  65.             (set! read-string
  66.               (%readline (if (string? prompt)
  67.                      prompt
  68.                      (prompt))
  69.                      input-port
  70.                      output-port
  71.                      read-hook))
  72.             (set! string-index 0)
  73.             (if (not (eof-object? read-string))
  74.             (begin
  75.               (or (string=? read-string "")
  76.                   (begin
  77.                 (add-history read-string)
  78.                 (set! prompt prompt2)))
  79.               (get-character))
  80.             read-string)))
  81.          (else 
  82.           (let ((res (string-ref read-string string-index)))
  83.             (set! string-index (+ 1 string-index))
  84.             res))))))          
  85.       (make-soft-port
  86.        (vector write-char display #f get-character #f)
  87.        "rw"))))
  88.  
  89. ;;; We only create one readline port.  There's no point in having
  90. ;;; more, since they would all share the tty and history ---
  91. ;;; everything except the prompt.  And don't forget the
  92. ;;; compile/load/run phase distinctions.  Also, the readline library
  93. ;;; isn't reentrant.
  94. (define the-readline-port #f)
  95.  
  96. (define history-variable "GUILE_HISTORY")
  97. (define history-file (string-append (getenv "HOME") "/.guile_history"))
  98.  
  99. (define-public readline-port
  100.   (let ((do (lambda (r/w)
  101.           (if (memq 'history-file (readline-options-interface))
  102.           (r/w (or (getenv history-variable)
  103.                history-file))))))
  104.     (lambda ()
  105.       (if (not the-readline-port)
  106.       (begin
  107.         (do read-history) 
  108.         (set! the-readline-port (make-readline-port))
  109.         (add-hook! exit-hook (lambda () (do write-history)))))
  110.       the-readline-port)))
  111.  
  112. ;;; The user might try to use readline in his programs.  It then
  113. ;;; becomes very uncomfortable that the current-input-port is the
  114. ;;; readline port...
  115. ;;;
  116. ;;; Here, we detect this situation and replace it with the
  117. ;;; underlying port.
  118. ;;;
  119. ;;; %readline is the low-level readline procedure.
  120.  
  121. (define-public (readline . args)
  122.   (let ((prompt prompt)
  123.     (inp input-port))
  124.     (cond ((not (null? args))
  125.        (set! prompt (car args))
  126.        (set! args (cdr args))
  127.        (cond ((not (null? args))
  128.           (set! inp (car args))
  129.           (set! args (cdr args))))))
  130.     (apply %readline
  131.        prompt
  132.        (if (eq? inp the-readline-port)
  133.            input-port
  134.            inp)
  135.        args)))
  136.  
  137. (define-public (set-readline-prompt! p . rest)
  138.   (set! prompt p)
  139.   (if (not (null? rest))
  140.       (set! prompt2 (car rest))))
  141.  
  142. (define-public (set-readline-input-port! p)
  143.   (set! input-port p))
  144.  
  145. (define-public (set-readline-output-port! p)
  146.   (set! output-port p))
  147.  
  148. (define-public (set-readline-read-hook! h)
  149.   (set! read-hook h))
  150.  
  151. (if (feature? 'regex)
  152.     (begin
  153.       (define-public apropos-completion-function
  154.     (let ((completions '()))
  155.       (lambda (text cont?)
  156.         (if (not cont?)
  157.         (set! completions
  158.               (map symbol->string
  159.                (apropos-internal
  160.                 (string-append "^" (regexp-quote text))))))
  161.         (if (null? completions)
  162.         #f
  163.         (let ((retval (car completions)))
  164.           (begin (set! completions (cdr completions))
  165.              retval))))))
  166.  
  167.       (set! *readline-completion-function* apropos-completion-function)
  168.       ))
  169.  
  170. (define-public (activate-readline)
  171.   (if (and (isatty? (current-input-port))
  172.        (not (and (module-defined? the-root-module
  173.                       'use-emacs-interface)
  174.              use-emacs-interface)))
  175.       (let ((read-hook (lambda () (run-hook before-read-hook))))
  176.     (set-current-input-port (readline-port))
  177.     (set! repl-reader
  178.           (lambda (prompt)
  179.         (dynamic-wind
  180.             (lambda ()
  181.               (set-readline-prompt! prompt "... ")
  182.               (set-readline-read-hook! read-hook))
  183.             (lambda () (read))
  184.             (lambda ()
  185.               (set-readline-prompt! "" "")
  186.               (set-readline-read-hook! #f)))))
  187.     (set! (using-readline?) #t))))
  188.